COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	procedures for building a Press file
C00005 00003	Output codes for Press format proofmode files
C00018 00004	code from MFOUT.SAI, modified for Press proof output
C00034 ENDMK
C⊗;
comment procedures for building a Press file;

comment When building a Press proofmode output file, we need some core.
On WAITS, the best thing to do is probably to just allocate this core
as an array.  But on TENEX, there is all this nifty core sitting up in
the high seg above the Metafont code but below the TENEX SAIL disk
buffers (which start at page '600) that is just begging to be used.
Hence, on TENEX, we perform various magic to allocate our Press
buffers up in that region.  There are three
different buffers:  elbuf is used for the entity list of a Press page,
dlbuf is the data list of a Press page, and partdirbuf is where the part
directory of the Press file is built.  Of these three, only the partdirbuf
has to survive for the entire run of Metafont:  the other two are
only needed on a character by character basis;

IFTENEX
preload_with 0;
saf integer array spacetopoach[0:0];

boolean procedure pageexists(integer pagenum);
begin
integer arg,res;
arg←(1 lsh 35)+pagenum;
internaldef rpacs=⊂jsys '57⊃;
	start_code
	move 1,arg;
	rpacs;
	movem 2,res;
	end;
return((res lsh -12) land 1);
end;

procedure highsegalloc(reference integer ptr; integer pagelen);
begin
integer freepages, pagenum;
if spacetopoach[0]=0 then 
	begin
	for pagenum←'450 step 1 until '600 do
		if not pageexists(pagenum) then done; 
	end
  else pagenum←spacetopoach[0];
freepages←'600-pagenum # page '600 is start of runtime's buffers;
if pagelen > freepages then
  errorstop("Not enough free space in high seg for Press output buffers!");
ptr←512*pagenum;
spacetopoach[0]←pagenum+pagelen;
end;
ENDTENEX;

comment Output codes for Press format proofmode files;

comment Press Entity list commands;
define
	ELShowCharactersShort = '0,
	ELSetSpaceXShort = '140,
	ELFont = '160,
	ELSetX = '356,
	ELSetY = '357,
	ELShowCharacters = '360,
	ELSetSpaceX = '364,
	ELResetSpace = '366,
	ELSetBrightness = '370,
	ELSetHue = '371,
	ELSetSaturation = '372,
	ELShowRectangle = '376,
	ELNop = '377;

integer cellsize, cellsh;
boolean rotated;
comment integer recnum # current record number;
define maxparts=400;
DEBUGONLY redefine maxparts=150;
define partdirlen=2*maxparts # 8 bytes per part entry;
ifc TENEX thenc
	define partdirlenpages=(partdirlen+511) div 512;
  elsec
	saf integer array partdirbuf[0:partdirlen-1];
  endc
comment integer pdptr, nparts # byte pointer into partdirbuf, number of parts;

define micasPerInch=⊂2540⊃;
define pageheight=⊂11*micasPerInch⊃, pagewidth=⊂8.5*micasPerInch⊃;

comment entity 1 removed (as compared with the TEX module TEXPRS);
define d0max=20000, e0max=50000;
comment max permissible data list, entity list counts (bytes);
DEBUGONLY redefine d0max=7000, e0max=15000;
define d0len=(d0max + 3) div 4, e0len=(e0max + 3) div 4;
ifc TENEX thenc
	define d0lenpages=(d0len+511) div 512, e0lenpages=(e0len+511) div 512;
  elsec
	saf integer array dlbuf[0:d0len-1];
	saf integer array elbuf[0:e0len-1];
  endc
integer dlbufptr, elbufptr # addresses of dlbuf and elbuf;
integer dlp, elp # byte pointers into dlbuf and elbuf;
DEBUGONLY integer dlmaxused # max attained data list count (bytes);
DEBUGONLY integer elmaxused # max attained entity list count (bytes);
integer dct, ect, pch, cx, cy, cf;

comment Procedures for dealing with DL and EL;

define pointbyte(ref)=⊂point(8,memory[ref],-1)⊃;

simp procedure ELByte (integer b);
	begin
	if ect≥e0max then overflow(ect);
	idpb(b, elp);
	ect←ect+1;
	end;

simp procedure ELWord (integer w);
	begin ELByte(w lsh -8); ELByte(w) end;

simp procedure ELDWord (integer d);
	begin ELWord(d lsh -16); ELWord(d) end;

simp procedure DLByte (integer b);
	begin
	if dct≥d0max then overflow(dct);
	idpb(b, dlp);
	dct←dct+1;
	end;

simp procedure DLWord (integer w);
	begin DLByte(w lsh -8); DLByte(w) end;

simp integer procedure PadRecord(integer padval);
	begin
	integer padlength, i;
	padlength←-(bytecount[proof] mod 512);
	if padlength<0 then padlength←padlength+512;
	for i←1 thru padlength do Bout(proof,padval);
	return(padlength);
	end;

simp procedure StartPage;
	begin
	comment initialize byte pointers into DL and EL;
	dlp←pointbyte(dlbufptr);
	elp←pointbyte(elbufptr);
	dct←0; ect←0; pch←0; cx←0; cy←0; cf←0;
	end;

simp procedure AddPart(integer parttype, beginrec, nrecs, pad(0));
	begin
	if nparts≥maxparts then overflow(nparts);
	idpb(parttype, pdptr);
	idpb(beginrec, pdptr);
	idpb(nrecs, pdptr);
	idpb(pad, pdptr);
	nparts←nparts+1;
	end;

simp procedure PutChar(integer c);
	begin
	DLByte(c); pch←pch+1;
	end;

simp procedure Flush;
	begin
	short integer n;
	n←pch;
	if n>0 then
		begin
		if n≤32 then ELByte(ELShowCharactersShort+n-1)
		else while n>0 do begin
			ELByte(ELShowCharacters); ELByte(n min 255);
			n←n-255;
		end;
		pch←0;
		end;
	end;

simp procedure SetX(integer x);
	begin
	Flush; ELByte(ELSetX); ELWord(x);
	end;

simp procedure SetY(integer y);
	begin
	y←pageheight-y # invert y direction;
	Flush; ELByte(ELSetY); ELWord(y);
	end;

simp procedure SetHue(integer x);
	begin Flush; ELByte(ELSetHue); ELByte(x);
	end;

simp procedure SetBrightnessAndSaturation;
	begin Flush; ELByte(ELSetBrightness); ELByte('377) # white;
	ELByte(ELSetSaturation); ELByte('377) # totally saturated;
	end;

simp procedure PutRectangle(integer x0,y0,h,w);
	begin comment x0,y0 specify the upper left corner;
	comment en←1 # put all rectangles in entity 1;
	Flush;
	SetX(x0); SetY(y0+h);
	ELByte(ELShowRectangle); ELWord(w); ELWord(h);
	end;

simp procedure SetFont(integer f);
	begin
	if cf≠f then begin Flush; ELByte(ELFont+(cf←f)); end;
	end;

comment append a trailer to entity list n;
simp procedure ETrailer(integer n, beginbyte, bytelength);
	begin
	Flush # don't forget to flush out pending characters!;
	if ect=0 then return # empty entity - leave it empty;
	if (ect mod 2) ≠ 0 then ELByte(ELNop) # pad to word boundary;
	ELByte(125) # type;
	ELByte(0) # font set;
	ELDWord(beginbyte) # beginning of DL region;
	ELDWord(bytelength) # length of DL region;
	ELWord(0); ELWord(0) # origin (Xe, Ye);
	ELWord(0); ELWord(0) # bottom left corner of bounding box;
	ELWord(pagewidth); ELWord(pageheight) # dimensions of bounding box;
	ELWord(ect div 2+1) # entity length in WORDS (including this number);
	comment Assertion: the entity now contains an even number of bytes;
	end;

define outch(c)=⊂PutChar((c)land '177)⊃ # macro for output of a single character;
simp procedure outchs(string str);
begin integer i;
for i←1 step 1 until length(str) do outch(str[i for 1])
end;
define outrule(x0,y0,h,w)=⊂PutRectangle(x0,y0,h,w)⊃;
define newfont(f)=⊂SetFont(f)⊃;

procedure finproofchar # the main output procedure,produces one page;
begin
integer padbytes, nextrec;

comment write data lists;
Sout(proof, dlbufptr, dct);
if (bytecount[proof] mod 2) ≠ 0 then Bout(proof,0) # pad to word boundary;
if (bytecount[proof] mod 4) ≠ 2 then Wout(proof,0) # pad to middle
	of a 32-bit word, so that Wout below brings you to a word
	boundary;

comment construct entity trailers;
ETrailer(0, 0, dct);

Wout(proof,0) # zero word to mark beginning of entity lists;
comment write entity lists;
Sout(proof, elbufptr, ect);
padbytes←PadRecord(ELNop);

nextrec←bytecount[proof] div 512;
AddPart(0, recnum, nextrec-recnum, padbytes div 2) # want WORDS of padding;
recnum←nextrec;

DEBUGONLY		dlmaxused←dlmaxused max dct;
DEBUGONLY		elmaxused←elmaxused max ect;

end;

procedure proofcloseout # just before TEX stops, do this;
begin integer n,f;
integer nextrec, logdir, dummy, pdlen, i;
string letters; integer lbt;

comment write the font directory part;
define entrylength=16 # in WORDS!!!;

for f←0 thru 1 do 
	begin
	Wout(proof,entrylength);
	Bout(proof,0) # font set;
	Bout(proof,f) # font number within set;
	Bout(proof,0); Bout(proof,'177) # first and last characters;
	comment family name is a bcpl string, max 20 bytes;
	BCPLout(proof,if f=0 then "TIMESROMAN" else "FIG", 20);
	Bout(proof,0) # face;
	Bout(proof,0) # "source" character;
	Wout(proof,if f=0 then 6 else
			if rotated then cellsize else cellsize+1)
	 # should really be in micas, but PressEdit didn't understand;
	Wout(proof,if f=1 and rotated then 5400 else 0) # rotation;
	end;
Wout(proof,0) # a zero word to mark the end of the font directory!;
PadRecord(0);
nextrec←bytecount[proof] div 512;
AddPart(1, recnum, nextrec-recnum);
recnum←nextrec;

comment write the part directory;
pdlen←8*nparts # 4 words (8 bytes) per part;
Sout(proof, partdirbufptr, pdlen);
PadRecord(0);
nextrec←bytecount[proof] div 512;

comment now, finally, the document directory;
Wout(proof,27183) # general password;
Wout(proof,nextrec+1) # total number of records in file (including this one);
Wout(proof,nparts) # number of parts;
Wout(proof,recnum) # start of part dir;
Wout(proof,nextrec-recnum) # number of records in part dir;
Wout(proof,-1) # back-pointer to obsolete document directory(?);
Dout(proof,altotime) # add current datetime in Alto format;
Wout(proof,1); Wout(proof,1) # first and last copy;
Wout(proof,-1); Wout(proof,-1) # first and last pages;
Wout(proof,"S") # printing mode is "solid";
comment That "S" also makes Viola send bit map instead of characters;
for i←13 thru '177 do Wout(proof,-1);
BCPLout(proof,ofilname, 2*26);
BCPLout(proof,username, 2*16);
BCPLout(proof,daytime, 2*20);
PadRecord(0);

end;

comment code from MFOUT.SAI, modified for Press proof output;
define PARCcomment=⊂comment⊃ # used to flag some of the differences
	between XGP and PRESS versions;

procedure makeproof # Outputs the raster in printable form;
begin
comment This routine figures out how to label the points, and then
it outputs the raster in a format that is printable with a special font.
The point label locations are computed in the following way: We go through
the points from top to bottom, left to right, and use the first available
position from a list of five choices:
	centered above the point
	centered to the left of the point
	centered to the right of the point
	centered below the point
	in the right margin below previous entries like this
(The last case always succeeds if the other four fail.) A position is
"available" if the corresponding box containing the symbolic name of the point
does not overlap with any previously placed boxes, and if this box is at least
two units away from every other point, measuring distance along vertical
and horizontal lines (Manhattan style). (The box is one unit away from
the point it corresponds to.)

Output for the XGP server is a sequence of 7-bit character codes of the following
types:
	'177&'001&'040&x1&x2, where x1&x2=x is a 14-bit binary number, x<4096
		means "move to column x"
	c, where c is a letter or digit or "."
		means "output character c in the FIG font and advance as many
			columns as c's width
	'012&'177&'003&y1&y2, where y1&y2=y is a 14-bit binary number
		means "move to row y (numbered from the top, increasing downwards)
	'015&'014&'177&'006&'001
		means "cut the paper at the current row (and select FIG font)"

;

define doverRes=⊂(384)⊃;
define xgptodover(x)=⊂((x) lsh cellsh+.9)*(micasPerInch/doverRes)⊃;
define movetocol(x)=⊂if rotated then SetY(xgptodover(xr-(x)+100))
	else SetX(xgptodover((x)-xl+50))⊃;
define movetorow(y)=⊂if rotated then SetX(xgptodover(yhigh-(y)+50))
	else SetY(xgptodover(yhigh-(y)+100))⊃;
define makehue(x)=⊂begin if curhue≠x then begin SetHue((x));
	curhue←x; movetorow(cury) end end⊃;

integer chrinit, ptinit # controlled by cellsize;
integer xl,xr,p,q,r,ch,y,x,state,curx,cury;
integer xwbase # position in \\{rast};
integer z,zw # current bit;
integer xbit,xbitl,xbitr;
integer zt,zr,zb,zl # bit patterns of neighbors;
integer c,mode	# encoding of neighborhood;
integer yextra # coordinate for case 5 labels;

procedure clearstate # Outputs bit codes that have accumulated;
begin comment This procedure is used in the routine that puts out the raster.
If state = n > 0, we output the code for n grey cells
(where P=1 cell, Q=2, R=4, etc.), while if state = -m < 0 we output
the code for m blanks;
integer pt # power of 2;
string chr # corresponding character;
if state<0 then
	begin movetorow(cury←cury-state); state←0; return end;
if color then
	begin if mode=15 then makehue(greyhue) else makehue(edgehue);
	end;
if state=1 then
	begin outch('117 xor mode); cury←cury+1; state←0; return end;
comment Now mode = 5 + 8L + 2R;
chr←case ((mode-5) lsh -1) of ('25,'35,"U","U",'45,"U");
pt←32 # the font has only "P", "Q", "R", "S", "T", and "U";
loop begin
	while state≥pt do
		begin outch(chr); state←state-pt; cury←cury+pt end;
	if state=0 then return;
	pt←pt lsh -1; chr←chr-1;
	end;
end;

PARCcomment initialize chrinit, ptinit;
comment chrinit←if cellsize=4 then "U" else "U";
comment ptinit←if cellsize=4 then 32 else 32;
xl←xleft*bitsperwd+(xrastmin+xpenmin) # leftmost bit position being output;
xr←xright*bitsperwd+(xrastmin+xpenmin+bitsperwd-1) # rightmost;
bxptr←0 # set list of active boxes empty;
yextra←yhigh;
p←0; if points then while llink[p]>p do p←llink[p] # start at topmost leftmost point;
while p do
	begin integer j # choice number for the label;
	integer m # four times the length of the label;
	integer x0,y0,x1,y1 # coordinates of the box;
	label advancep # go here when done with $p$;
	if xcoord[p]<xl or xcoord[p]>xr or ycoord[p]>yhigh or ycoord[p]<ylow
		or strng[p]=0
		then go to advancep # points out of range won't be shown;
	m←4*length(strng[p]);
	for j←1 thru 5 do
		begin integer q # runs through things that shouldn't clash;
		label reject # go here when case $j$ is illegal;
		case j of begin
		[1] begin x0←xcoord[p]-1-m; y0←ycoord[p]+1 end;
		[2] begin x0←xcoord[p]-3-2*m; y0←ycoord[p]-5 end;
		[3] begin x0←xcoord[p]+1; y0←ycoord[p]-5 end;
		[4] begin x0←xcoord[p]-1-m; y0←ycoord[p]-11 end;
		else begin x0←infty; done end
		  end;
		x1←x0+2+2*m; y1←y0+10;
		q←p # first we will check points just before $p$;
		loop	begin integer x,y,r # temporary storage;
			integer dist # Manhattan distance;
			if (r←llink[q])≤q then
				if r then q←r else done
			else	begin q←r; while (r←rlink[q])>q do q←r;
				end;
			comment The above lines moved $q$ backwards one;
			y←ycoord[q]; if y>y1+1 then done # no clash possible;
			if y≥y1 then dist←y-y1 else if y≤y0 then dist←y0-y
			else dist←0;
			x←xcoord[q]; if x≥x1 then dist←dist+x-x1 else if
			x≤x0 then dist←dist+x0-x;
			if dist≤1 then go to reject;
			end;
		q←p # next we will check points just after $p$;
		loop	begin integer x,y,r # temporary storage;
			integer dist # Manhattan distance;
			if (r←rlink[q])≤q then
				if r then q←r else done
			else	begin q←r; while (r←llink[q])>q do q←r;
				end;
			comment The above lines moved $q$ forwards one;
			y←ycoord[q]; if y<y0-1 then done # no clash possible;
			if y≥y1 then dist←y-y1 else if y≤y0 then dist←y0-y
			else dist←0;
			x←xcoord[q]; if x≥x1 then dist←dist+x-x1 else if
			x≤x0 then dist←dist+x0-x;
			if dist≤1 then go to reject;
			end;
		q←bxptr # finally we check that no overlap occurs;
		while q do
			begin
			if yll[q]>y1 then done;
			if x1≥xll[q] and x0≤xur[q] and y0≤yll[q]+10
				then go to reject;
			q←prevbox[q];
			end;
		done # all tests have been passed;
		reject: # this value of $j$ didn't work;
		end;
	if x0=infty then
		begin comment case 5;
		xll[p]←(xright-xleft)*bitsperwd+(bitsperwd+24);
		xur[p]←xll[p]+2*m+2;
		yextra←yextra-20; yll[p]←yextra;
		end
	else	begin comment case 1, 2, 3, or 4;
		xll[p]←x0; xur[p]←x1; yll[p]←y0;
		end;
	q←bxptr; r←0;
	while q and yll[q]<yll[p] do
		begin r←q; q←prevbox[q];
		end;
	prevbox[p]←q; if r then prevbox[r]←p else bxptr←p;
	advancep:
	if (r←rlink[p])≤p then p←r
	else	begin p←r; while (r←llink[p])>p do p←r;
		end;
	end;
comment Now all points have been output, so we output the raster pattern.
White spaces are handled by "skips", but grey cells are classified into
sixteen kinds according to the presence or absence of neighbors above, right,
below, or left of a cell. An ordinary cell has all four neighbors present.
Codes "A", "B", ..., "O" are used for the cases when one or more neighbors
is absent, using a binary code. The "fig" font uses this information to put
boundary lines at the edges.

The "fig" font is designed so that character "." placed at location (x,y) indicates
a big black dot centered on cell (x,y). The digits 0...9 and lower case letters
are designed to have a width of 8 cells, and so that the character will be
approximately centered in an 11x11 rectangle whose lower left corner is (x0,y0) and
whose upper right corner is (x0+10,y0+10) if the string begins at cell (x0+2,y0+8).;

comment First we relink the point label boxes into down-the-page order and increase
the \\{xll} and \\{yll} coordinates to account for the font offset;
q←0; while bxptr do
	begin r←prevbox[bxptr]; prevbox[bxptr]←q; q←bxptr; bxptr←r;
	xll[q]←xll[q]+2; yll[q]←yll[q]+8;
	end;
bxptr←q;

ch←openofil(proof); StartPage # begin a new page of output;
if not arrow then begin
SetY(1270) # insert page number and time at XGP row 50;
SetX(1270) # beginning at XGP column 100;
newfont(0) # selecting font 0;
outchs(prfheader&cvs(prfpno←prfpno+1));
if pagewarning then outchs("     "&pagewarning);
end;
newfont(1) # then select font 1;
curhue←-1;
if color then SetBrightnessAndSaturation;

comment Now output raster;
curx←xl-1;
for x←xleft thru xright do
for xbit←-35 thru 0 do
	begin
	movetocol(curx←curx+1);
	state←-1; cury←ylow-1;
	xwbase←x*rspan;
	z←0; zt←rast[xwbase+ylow] lsh xbit land 1;
		xbitl←xbit-1+3; xbitr←xbit+1+1;
	for y←ylow thru yhigh do
		begin
		define xw=⊂xwbase+y⊃;
		zb←z lsh 2; z←zt;
		if y≠yhigh then zt←rast[xw+1] lsh xbit land 1 else zt←0;
		if z=0 then
			begin if state>0 then clearstate; state←state-1 end
		else
			begin	# bit is dark;
			zw←rast[xw];
			if xbit neq -35 then zl←zw lsh xbitl land 8
				else if x=xleft then zl←0
					else zl←rast[xw-rspan] lsh 3 land 8;
			if xbit neq 0 then zr←zw lsh xbitr land 2
				else if x=xright then zr←0
					else zr←rast[xw+rspan] lsh -35 lsh 1;
			c ← zl + zb + zr + zt;
			if state<0 or c neq mode then
				begin if state≠0 then clearstate; mode←c end;
			state←state+1;
			end;
		end;
	if state>0 then clearstate;
	end;

if color then makehue(dothue);
	while bxptr do
		begin comment Outputting a point label;
		movetorow(yll[bxptr]);
		movetocol(xll[bxptr]);
		outchs(strng[bxptr]);
		bxptr←prevbox[bxptr];
		end;

p←0;
if points then while llink[p]>p do p←llink[p] # go to the topmost leftmost point;
	while p do
		begin comment Outputting a point dot;
		if ycoord[p]≤yhigh and ycoord[p]≥ylow and xcoord[p]≥xl and
			xcoord[p]≤xr then
			begin movetorow(ycoord[p]);
			movetocol(xcoord[p]);
			outch(".");
			end;
		if (r←rlink[p])≤p then p←r
		else	begin p←r; while (r←llink[p])>p do p←r;
			end;
		end;


PARCcomment put "arrow" at origin (for pressedit);
if arrow then begin movetorow(0); movetocol(0); newfont(0); outchs("<==<<") end;
PARCcomment output data for this character (see PRESSOUT.SAI);
finproofchar;
end;